home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / sernum.zip / SERNUM.PAS
Pascal/Delphi Source File  |  1993-05-07  |  3KB  |  127 lines
  1. PROGRAM Serial;
  2. CONST
  3.   HexDigits : ARRAY[0..15] OF Char = '0123456789ABCDEF';
  4. TYPE
  5.   InfoBuffer = RECORD
  6.     InfoLevel  : Word; {should be zero}
  7.     Serial     : LongInt;
  8.     VolLabel   : ARRAY[0..10] OF Char;
  9.     FileSystem : ARRAY[0..7] OF Char;
  10.   END;
  11.   SerString = String[9];
  12.  
  13. VAR
  14.   IB        : InfoBuffer;
  15.   N         : Word;
  16.   let       : Char;
  17.   param     : String[10];
  18.   IsSet     : Boolean;
  19.   NewSerial : LongInt;
  20.   code      : Integer;
  21.  
  22.   FUNCTION SerialStr(L : LongInt) : SerString;
  23.   VAR Temp : SerString;
  24.   BEGIN
  25.     Temp[0] := #9;
  26.     Temp[1] := HexDigits[L SHR 28];
  27.     Temp[2] := HexDigits[(L SHR 24) AND $F];
  28.     Temp[3] := HexDigits[(L SHR 20) AND $F];
  29.     Temp[4] := HexDigits[(L SHR 16) AND $F];
  30.     Temp[5] := '-';
  31.     Temp[6] := HexDigits[(L SHR 12) AND $F];
  32.     Temp[7] := HexDigits[(L SHR 8) AND $F];
  33.     Temp[8] := HexDigits[(L SHR 4) AND $F];
  34.     Temp[9] := HexDigits[L AND $F];
  35.     SerialStr := Temp;
  36.   END;
  37.  
  38.   FUNCTION GetSerial(DiskNum : Byte;
  39.     VAR I : InfoBuffer) : Word; Assembler;
  40.   ASM
  41.     MOV AH, 69h
  42.     MOV AL, 00h
  43.     MOV BL, DiskNum
  44.     PUSH DS
  45.     LDS DX, I
  46.     INT 21h
  47.     POP DS
  48.     JC @Bad
  49.     XOR AX, AX
  50.     @Bad:
  51.   END;
  52.  
  53.   FUNCTION SetSerial(DiskNum : Byte;
  54.     VAR I : InfoBuffer) : Word; Assembler;
  55.   ASM
  56.     MOV AH, 69h
  57.     MOV AL, 01h
  58.     MOV BL, DiskNum
  59.     PUSH DS
  60.     LDS DX, I
  61.     INT 21h
  62.     POP DS
  63.     JC @Bad
  64.     XOR AX, AX
  65.     @Bad:
  66.   END;
  67.  
  68.   PROCEDURE ErrorOut(err : Byte);
  69.   BEGIN
  70.     CASE err OF
  71.       5   : BEGIN
  72.               WriteLn('Either the disk in ',let,': is write-',
  73.                 'protected or it lacks an extended BPB.');
  74.               WriteLn('If the disk is not write-protected, ',
  75.                 'reformat with DOS 4 or higher.');
  76.             END;
  77.       15  : WriteLn('Not a valid drive letter.');
  78.       255 : BEGIN
  79.               WriteLn('SYNTAX: "Serial d: ########"');
  80.               WriteLn('  where d: is the drive letter ',
  81.                       'and ######## is the eight-digit');
  82.               WriteLn('  hexadecimal serial number.');
  83.               WriteLn('EXAMPLE: "Serial 1234ABCD"');
  84.             END;
  85.       ELSE WriteLn('DOS ERROR #',N);
  86.     END;
  87.     Halt(1);
  88.   END;
  89.  
  90. BEGIN
  91.   IF ParamCount < 1 THEN ErrorOut(255);
  92.   IF ParamCount > 2 THEN ErrorOut(255);
  93.   Param := ParamStr(1);
  94.   CASE length(Param) OF
  95.     1 : ; {ok}
  96.     2 : IF Param[2] <> ':' THEN ErrorOut(255);
  97.     ELSE ErrorOut(255);
  98.   END;
  99.   Let := UpCase(Param[1]);
  100.   IF (Let < 'A') OR (Let > 'Z') THEN ErrorOut(15);
  101.   IF ParamCount < 2 THEN IsSet := FALSE
  102.   ELSE
  103.     BEGIN
  104.       IsSet := TRUE;
  105.       Param := '$'+ParamStr(2);
  106.       Val(Param, NewSerial, Code);
  107.       IF Code <> 0 THEN ErrorOut(255);
  108.     END;
  109.   N := GetSerial(Ord(Let)-Ord('@'), IB);
  110.   IF N = 0 THEN
  111.     BEGIN
  112.       WITH IB DO
  113.         BEGIN
  114.           WriteLn('Serial number is "', SerialStr(Serial),'"');
  115.           IF IsSet THEN
  116.             BEGIN
  117.               Serial := NewSerial;;
  118.               N := SetSerial(Ord(Let)-Ord('@'), IB);
  119.               IF N = 0 THEN
  120.                 WriteLn('Successfully changed serial to "',
  121.                         SerialStr(NewSerial),'"')
  122.               ELSE ErrorOut(N);
  123.             END;
  124.         END;
  125.     END
  126.   ELSE ErrorOut(N);
  127. END.